;;;functions that manipulate arithmetic expressions

(DEFPROP DIFF (
	DIFF
        NUMVAL
	EVPLUS
	EVTIMES
	SIMP 
	SIMP1 
	SPLUS 
	STIMES 
	SOP
	PLUSSOP
	MONOMIAL
	TIMESOP
	DISTRIB
	MONPROD
	MAPAPP
) DIFFFNS)
;;;DIFF symbolically differentiates arithmetic expressions

(DEFUN DIFF (E V) 
  (COND	((ATOM E) (COND ((EQ E V) 1) (T 0)))
	((EQ (CAR E) 'PLUS)
	 (CONS 'PLUS
	       (MAPCAR (FUNCTION (LAMBDA (X) (DIFF X V))) (CDR E))))
	((EQ (CAR E) 'TIMES)
	 (CONS 'PLUS
	       (MAPLIST (FUNCTION 
			  (LAMBDA (X) 
			    (CONS 'TIMES
				  (MAPLIST (FUNCTION 
					    (LAMBDA (Y) 
					      (COND ((EQ X Y) (DIFF (CAR Y) V))
						    (T (CAR Y)))))
					   (CDR E)))))
	                (CDR E))))))
;;;arithmetic expression evaluator

(DEFUN NUMVAL (E A)
  (COND ((NUMBERP E) E)
	((ATOM E) (CDR (ASSOC E A))
	((EQ (CAR E) 'PLUS) (EVPLUS (CDR E) A))
	((EQ (CAR E) 'TIMES) (EVTIMES (CDR E) A)) ))

(DEFUN EVPLUS (U A)
  (COND ((NULL U) 0) (T (PLUS (NUMVAL (CAR U) A) (EVPLUS (CDR U) A))) ))

(DEFUN EVTIMES (U A)
  (COND ((NULL U) 1) (T (TIMES (NUMVAL (CAR U) A) (EVTIMES (CDR U) A))) ))
;;;SIMP simplifies arith expressions

(DEFUN SIMP (U)
  (COND ((ATOM U) U)
	(T ((LAMBDA (W) (COND ((EQUAL W U) U) (T (SIMP W))))
	    (SIMP1 (CONS (CAR U) 
		         (MAPLIST (FUNCTION (LAMBDA (Z) (SIMP (CAR Z)))) 
				  (CDR U)))))))) 

(DEFUN SIMP1 (E)
  (COND ((EQ (CAR E) (QUOTE MINUS))
         (COND ((AND (NOT (ATOM (CADR E))) (EQ (CAADR E) (QUOTE MINUS))) (CADADR E))
               (T E)))
	((EQ (CAR E) (QUOTE PLUS))
         ((LAMBDA (W) 
            (COND ((NULL W) 0) ((NULL (CDR W)) (CAR W)) (T (CONS (QUOTE PLUS) W)))) 
          (SPLUS (CDR E))))
        ((EQ (CAR E) (QUOTE TIMES))
         ((LAMBDA (W) 
	    (COND ((NULL W) 1) 
		  ((EQ W (QUOTE NO)) 0) 
		  ((NULL (CDR W)) (CAR W)) 
		  (T (CONS (QUOTE TIMES) W))))
          (STIMES (CDR E)))))) 

(DEFUN SPLUS (U) 
  (COND ((NULL U) NIL) 
	((EQ (CAR U) 0) (SPLUS (CDR U))) 
	(T (CONS (CAR U) (SPLUS (CDR U)))))) 

(DEFUN STIMES (U)
  (COND ((NULL U) NIL)
	(T ((LAMBDA (W)
	      (COND ((EQ W (QUOTE NO)) W) 
		    ((EQ (CAR U) 0) (QUOTE NO)) 
		    ((EQ (CAR U) 1) W) 
		    (T (CONS (CAR U) W))))
	    (STIMES (CDR U)))))) 
;;;SOP returns sum of products normal form for arith expressions


(DEFUN SOP (E) 
       (COND ((ATOM E) E)
	     ((EQ (CAR E) 'PLUS)
	      (CONS 'PLUS
		    (PLUSSOP (MAPCAR (FUNCTION SOP) (CDR E)))))
	     ((EQ (CAR E) 'TIMES)
	      (TIMESOP (MAPCAR (FUNCTION SOP) (CDR E))))))

(DEFUN PLUSSOP (U) 
       (COND ((NULL U) NIL)
	     ((MONOMIAL (CAR U)) (CONS (CAR U) (PLUSSOP (CDR U))))
	     (T (APPEND (CDAR U) (PLUSSOP (CDR U))))))

(DEFUN MONOMIAL (E) (OR (ATOM E) (EQ (CAR E) 'TIMES)))

(DEFUN TIMESOP (U) 
       (COND ((NULL (CDR U)) (CAR U))
	     (T (DISTRIB (CAR U) (TIMESOP (CDR U))))))

(DEFUN DISTRIB (S1 S2) 
       (COND
	((MONOMIAL S2)
	 (COND ((MONOMIAL S1) (MONPROD S1 S2))
	       (T (CONS 'PLUS
			(MAPCAR (FUNCTION (LAMBDA (X) (MONPROD X S2)))
				(CDR S1))))))
	((MONOMIAL S1)
	 (CONS 'PLUS
	       (MAPCAR (FUNCTION (LAMBDA (Y) (MONPROD S1 Y))) (CDR S2))))
	(T
	 (CONS
	  'PLUS
	  (MAPAPP 
	   (FUNCTION (LAMBDA (X) (MAPCAR (FUNCTION (LAMBDA (Y) 
							   (MONPROD X Y)))
					 (CDR S2))))
	   (CDR S1))))))

(DEFUN MONPROD (M1 M2) 
       (CONS 'TIMES
	     (COND ((ATOM M1)
		    (COND ((ATOM M2) (LIST M1 M2))
			  (T (CONS M1 (CDR M2)))))
		   (T (APPEND (CDR M1)
			      (COND ((ATOM M2) (NCONS M2))
				    (T (CDR M2)))))))) 
(DEFUN MAPAPP (FN U)
  (COND ((NULL U) NIL)
	(T (APPEND (APPLY FN (LIST(CAR U))) (MAPAPP FN (CDR U)))) ))